home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / DIRS.SWG / 0028_Directory Select Function.pas < prev    next >
Pascal/Delphi Source File  |  1994-02-22  |  15KB  |  485 lines
  1. Program DIRSEL;
  2. Uses
  3.    Crt,Dos;  { ** needed for DIRSELECT functions ** }
  4.  
  5. { ** The following Type & Var declarations are for the main program only  ** }
  6. { ** However, the string length of the returned parameter from DIRSELECT  ** }
  7. { ** must be a least 12 characters.                                       ** }
  8.  
  9. Type
  10.    strtype = String[12];
  11. Var
  12.    spec,fname : strtype;
  13.  
  14. { ************************************************************************** }
  15. { ** List of Procedures/Functions needed for DIRSELECT                    ** }
  16. { ** Procedure CURSOR     - turns cursor on or off                        ** }
  17. { ** Procedure FRAME      - draws single or double frame                  ** }
  18. { ** Function ISCOLOR     - returns the current video mode                ** }
  19. { ** Procedure SAVESCR    - saves current video screen                    ** }
  20. { ** Procedure RESTORESCR - restores old video screen                     ** }
  21. { ** Procedure SCRGET     - get character/attribute                       ** }
  22. { ** Procedure SCRPUT     - put character/attribute                       ** }
  23. { ** Procedure FNAMEPOS   - finds proper screen position                  ** }
  24. { ** Procedure HILITE     - highlights proper name                        ** }
  25. { ** Function DIRSELECT   - directory selector                            ** }
  26. { ************************************************************************** }
  27.  
  28. Procedure CURSOR( attrib : Boolean );
  29. Var
  30.    regs : Registers;
  31. Begin
  32.    If NOT attrib Then { turn cursor off }
  33.    Begin
  34.       regs.ah := 1;
  35.       regs.cl := 7;
  36.       regs.ch := 32;
  37.       Intr($10,regs)
  38.    End
  39.    Else { turn cursor on }
  40.    Begin
  41.       Intr($11,regs);
  42.       regs.cx := $0607;
  43.       If regs.al AND $10 <> 0 Then regs.cx := $0B0C;
  44.       regs.ah := 1;
  45.       Intr($10,regs)
  46.    End
  47. End;
  48.  
  49. Procedure FRAME(t,l,b,r,ftype : Integer);
  50. Var
  51.    i : Integer;
  52. Begin
  53.    GoToXY(l,t);
  54.    If ftype = 2 Then
  55.       Write(Chr(201))
  56.    Else
  57.       Write(Chr(218));
  58.    GoToXY(r,t);
  59.    If ftype = 2 Then
  60.       Write(Chr(187))
  61.    Else
  62.       Write(Chr(191));
  63.    GoToXY(l+1,t);
  64.    For i := 1 To (r - (l + 1)) Do
  65.       If ftype = 2 Then
  66.          Write(Chr(205))
  67.       Else
  68.          Write(Chr(196));
  69.    GoToXY(l+1,b);
  70.    For i := 1 To (r - (l + 1)) Do
  71.       If ftype = 2 Then
  72.          Write(Chr(205))
  73.       Else
  74.          Write(Chr(196));
  75.    GoToXY(l,b);
  76.    If ftype = 2 Then
  77.       Write(Chr(200))
  78.    Else
  79.       Write(Chr(192));
  80.    GoToXY(r,b);
  81.    If ftype = 2 Then
  82.       Write(Chr(188))
  83.    Else
  84.       Write(Chr(217));
  85.    For i := (t+1) To (b-1) Do
  86.    Begin
  87.       GoToXY(l,i);
  88.       If ftype = 2 Then
  89.          Write(Chr(186))
  90.       Else
  91.          Write(Chr(179))
  92.    End;
  93.    For i := (t+1) To (b-1) Do
  94.    Begin
  95.       GoToXY(r,i);
  96.       If ftype = 2 Then
  97.          Write(Chr(186))
  98.       Else
  99.          Write(Chr(179))
  100.    End
  101. End;
  102.  
  103. Function ISCOLOR : Boolean;  { returns FALSE for MONO or TRUE for COLOR }
  104. Var
  105.    regs       : Registers;
  106.    video_mode : Integer;
  107.    equ_lo     : Byte;
  108. Begin
  109.    Intr($11,regs);
  110.    video_mode := regs.al and $30;
  111.    video_mode := video_mode shr 4;
  112.    Case video_mode of
  113.       1 : ISCOLOR := FALSE;  { Monochrome }
  114.       2 : ISCOLOR := TRUE    { Color }
  115.    End
  116. End;
  117.  
  118. Procedure SAVESCR( Var screen );
  119. Var
  120.    vidc : Byte Absolute $B800:0000;
  121.    vidm : Byte Absolute $B000:0000;
  122. Begin
  123.    If NOT ISCOLOR Then  { if MONO }
  124.       Move(vidm,screen,4000)
  125.    Else                 { else COLOR }
  126.       Move(vidc,screen,4000)
  127. End;
  128.  
  129. Procedure RESTORESCR( Var screen );
  130. Var
  131.    vidc : Byte Absolute $B800:0000;
  132.    vidm : Byte Absolute $B000:0000;
  133. Begin
  134.    If NOT ISCOLOR Then  { if MONO }
  135.       Move(screen,vidm,4000)
  136.    Else                 { else COLOR }
  137.       Move(screen,vidc,4000)
  138. End;
  139.  
  140. Procedure SCRGET( Var ch,attr : Byte );
  141. Var
  142.    regs : Registers;
  143. Begin
  144.    regs.bh := 0;
  145.    regs.ah := 8;
  146.    Intr($10,regs);
  147.    ch := regs.al;
  148.    attr := regs.ah
  149. End;
  150.  
  151. Procedure SCRPUT( ch,attr : Byte );
  152. Var
  153.    regs : Registers;
  154. Begin
  155.    regs.al := ch;
  156.    regs.bl := attr;
  157.    regs.ch := 0;
  158.    regs.cl := 1;
  159.    regs.bh := 0;
  160.    regs.ah := 9;
  161.    Intr($10,regs);
  162. End;
  163.  
  164. Procedure FNAMEPOS(Var arypos,x,y : Integer);
  165. { determine position on screen of filename }
  166. Const
  167.    FPOS1 =  2;
  168.    FPOS2 = 15;
  169.    FPOS3 = 28;
  170.    FPOS4 = 41;
  171.    FPOS5 = 54;
  172.    FPOS6 = 67;
  173. Begin
  174.    Case arypos of
  175.         1: Begin x := FPOS1; y :=  2 End;
  176.         2: Begin x := FPOS2; y :=  2 End;
  177.         3: Begin x := FPOS3; y :=  2 End;
  178.         4: Begin x := FPOS4; y :=  2 End;
  179.         5: Begin x := FPOS5; y :=  2 End;
  180.         6: Begin x := FPOS6; y :=  2 End;
  181.         7: Begin x := FPOS1; y :=  3 End;
  182.         8: Begin x := FPOS2; y :=  3 End;
  183.         9: Begin x := FPOS3; y :=  3 End;
  184.        10: Begin x := FPOS4; y :=  3 End;
  185.        11: Begin x := FPOS5; y :=  3 End;
  186.        12: Begin x := FPOS6; y :=  3 End;
  187.        13: Begin x := FPOS1; y :=  4 End;
  188.        14: Begin x := FPOS2; y :=  4 End;
  189.        15: Begin x := FPOS3; y :=  4 End;
  190.        16: Begin x := FPOS4; y :=  4 End;
  191.        17: Begin x := FPOS5; y :=  4 End;
  192.        18: Begin x := FPOS6; y :=  4 End;
  193.        19: Begin x := FPOS1; y :=  5 End;
  194.        20: Begin x := FPOS2; y :=  5 End;
  195.        21: Begin x := FPOS3; y :=  5 End;
  196.        22: Begin x := FPOS4; y :=  5 End;
  197.        23: Begin x := FPOS5; y :=  5 End;
  198.        24: Begin x := FPOS6; y :=  5 End;
  199.        25: Begin x := FPOS1; y :=  6 End;
  200.        26: Begin x := FPOS2; y :=  6 End;
  201.        27: Begin x := FPOS3; y :=  6 End;
  202.        28: Begin x := FPOS4; y :=  6 End;
  203.        29: Begin x := FPOS5; y :=  6 End;
  204.        30: Begin x := FPOS6; y :=  6 End;
  205.        31: Begin x := FPOS1; y :=  7 End;
  206.        32: Begin x := FPOS2; y :=  7 End;
  207.        33: Begin x := FPOS3; y :=  7 End;
  208.        34: Begin x := FPOS4; y :=  7 End;
  209.        35: Begin x := FPOS5; y :=  7 End;
  210.        36: Begin x := FPOS6; y :=  7 End;
  211.        37: Begin x := FPOS1; y :=  8 End;
  212.        38: Begin x := FPOS2; y :=  8 End;
  213.        39: Begin x := FPOS3; y :=  8 End;
  214.        40: Begin x := FPOS4; y :=  8 End;
  215.        41: Begin x := FPOS5; y :=  8 End;
  216.        42: Begin x := FPOS6; y :=  8 End;
  217.        43: Begin x := FPOS1; y :=  9 End;
  218.        44: Begin x := FPOS2; y :=  9 End;
  219.        45: Begin x := FPOS3; y :=  9 End;
  220.        46: Begin x := FPOS4; y :=  9 End;
  221.        47: Begin x := FPOS5; y :=  9 End;
  222.        48: Begin x := FPOS6; y :=  9 End;
  223.        49: Begin x := FPOS1; y := 10 End;
  224.        50: Begin x := FPOS2; y := 10 End;
  225.        51: Begin x := FPOS3; y := 10 End;
  226.        52: Begin x := FPOS4; y := 10 End;
  227.        53: Begin x := FPOS5; y := 10 End;
  228.        54: Begin x := FPOS6; y := 10 End;
  229.        55: Begin x := FPOS1; y := 11 End;
  230.        56: Begin x := FPOS2; y := 11 End;
  231.        57: Begin x := FPOS3; y := 11 End;
  232.        58: Begin x := FPOS4; y := 11 End;
  233.        59: Begin x := FPOS5; y := 11 End;
  234.        60: Begin x := FPOS6; y := 11 End;
  235.        61: Begin x := FPOS1; y := 12 End;
  236.        62: Begin x := FPOS2; y := 12 End;
  237.        63: Begin x := FPOS3; y := 12 End;
  238.        64: Begin x := FPOS4; y := 12 End;
  239.        65: Begin x := FPOS5; y := 12 End;
  240.        66: Begin x := FPOS6; y := 12 End;
  241.        67: Begin x := FPOS1; y := 13 End;
  242.        68: Begin x := FPOS2; y := 13 End;
  243.        69: Begin x := FPOS3; y := 13 End;
  244.        70: Begin x := FPOS4; y := 13 End;
  245.        71: Begin x := FPOS5; y := 13 End;
  246.        72: Begin x := FPOS6; y := 13 End;
  247.        73: Begin x := FPOS1; y := 14 End;
  248.        74: Begin x := FPOS2; y := 14 End;
  249.        75: Begin x := FPOS3; y := 14 End;
  250.        76: Begin x := FPOS4; y := 14 End;
  251.        77: Begin x := FPOS5; y := 14 End;
  252.        78: Begin x := FPOS6; y := 14 End;
  253.        79: Begin x := FPOS1; y := 15 End;
  254.        80: Begin x := FPOS2; y := 15 End;
  255.        81: Begin x := FPOS3; y := 15 End;
  256.        82: Begin x := FPOS4; y := 15 End;
  257.        83: Begin x := FPOS5; y := 15 End;
  258.        84: Begin x := FPOS6; y := 15 End;
  259.        85: Begin x := FPOS1; y := 16 End;
  260.        86: Begin x := FPOS2; y := 16 End;
  261.        87: Begin x := FPOS3; y := 16 End;
  262.        88: Begin x := FPOS4; y := 16 End;
  263.        89: Begin x := FPOS5; y := 16 End;
  264.        90: Begin x := FPOS6; y := 16 End;
  265.        91: Begin x := FPOS1; y := 17 End;
  266.        92: Begin x := FPOS2; y := 17 End;
  267.        93: Begin x := FPOS3; y := 17 End;
  268.        94: Begin x := FPOS4; y := 17 End;
  269.        95: Begin x := FPOS5; y := 17 End;
  270.        96: Begin x := FPOS6; y := 17 End;
  271.        97: Begin x := FPOS1; y := 18 End;
  272.        98: Begin x := FPOS2; y := 18 End;
  273.        99: Begin x := FPOS3; y := 18 End;
  274.       100: Begin x := FPOS4; y := 18 End;
  275.       101: Begin x := FPOS5; y := 18 End;
  276.       102: Begin x := FPOS6; y := 18 End;
  277.       103: Begin x := FPOS1; y := 19 End;
  278.       104: Begin x := FPOS2; y := 19 End;
  279.       105: Begin x := FPOS3; y := 19 End;
  280.       106: Begin x := FPOS4; y := 19 End;
  281.       107: Begin x := FPOS5; y := 19 End;
  282.       108: Begin x := FPOS6; y := 19 End;
  283.       109: Begin x := FPOS1; y := 20 End;
  284.       110: Begin x := FPOS2; y := 20 End;
  285.       111: Begin x := FPOS3; y := 20 End;
  286.       112: Begin x := FPOS4; y := 20 End;
  287.       113: Begin x := FPOS5; y := 20 End;
  288.       114: Begin x := FPOS6; y := 20 End;
  289.       115: Begin x := FPOS1; y := 21 End;
  290.       116: Begin x := FPOS2; y := 21 End;
  291.       117: Begin x := FPOS3; y := 21 End;
  292.       118: Begin x := FPOS4; y := 21 End;
  293.       119: Begin x := FPOS5; y := 21 End;
  294.       120: Begin x := FPOS6; y := 21 End
  295.       Else
  296.       Begin
  297.          x := 0;
  298.          y := 0;
  299.       End
  300.    End
  301. End;
  302.  
  303. Procedure HILITE(old,new : Integer);  { highlight a filename on the screen }
  304. Var
  305.    i,oldx,oldy,newx,newy : Integer;
  306.    ccolor,locolor,hicolor,cchar : Byte;
  307. Begin
  308.    FNAMEPOS(old,oldx,oldy); { get position in the array of the filename }
  309.    FNAMEPOS(new,newx,newy); { get position in the array of the filename }
  310.    For i := 0 To 11 Do
  311.    Begin
  312.       If old < 121 Then  { if valid position, reverse video, old selection }
  313.       Begin
  314.          GoToXY((oldx + i),oldy);
  315.          SCRGET(cchar,ccolor);
  316.          locolor := ccolor AND $0F;
  317.          locolor := locolor shl 4;
  318.          hicolor := ccolor AND $F0;
  319.          hicolor := hicolor shr 4;
  320.          ccolor  := locolor + hicolor;
  321.          SCRPUT(cchar,ccolor)
  322.       End;
  323.       GoToXY((newx + i),newy);         { reverse video, new selection }
  324.       SCRGET(cchar,ccolor);
  325.       locolor := ccolor AND $0F;
  326.       locolor := locolor shl 4;
  327.       hicolor := ccolor AND $F0;
  328.       hicolor := hicolor shr 4;
  329.       ccolor  := locolor + hicolor;
  330.       SCRPUT(cchar,ccolor)
  331.    End
  332. End;
  333.  
  334. Function DIRSELECT(mask : strtype; attr : Integer) : strtype;
  335. Const
  336.    OFF   = FALSE;
  337.    ON    = TRUE;
  338. Var
  339.    i,oldcurx,oldcury,
  340.    newcurx,newcury,
  341.    oldpos,newpos,
  342.    scrrows,fncnt        : Integer;
  343.    ch                   : Char;
  344.    dos_dir              : Array[1..120] of String[12];
  345.    fileinfo             : SearchRec;
  346.    screen               : Array[1..4000] of Byte;
  347. Begin
  348.    fncnt := 0;
  349.    FindFirst(mask,attr,fileinfo);
  350.    If DosError <> 0 Then   { if not found, return NULL }
  351.    Begin
  352.       DIRSELECT := '';
  353.       Exit
  354.    End;
  355.    While (DosError = 0) AND (fncnt <> 120) Do   { else, collect filenames }
  356.    Begin
  357.       Inc(fncnt);
  358.       dos_dir[fncnt] := fileinfo.Name;
  359.       FindNext(fileinfo)
  360.    End;
  361.    oldcurx := WhereX;     { store old CURSOR position }
  362.    oldcury := WhereY;
  363.    SAVESCR(screen);
  364.    CURSOR(OFF);
  365.    scrrows := (fncnt DIV 6) + 3;
  366.    Window(1,1,80,scrrows + 1);
  367.    ClrScr;
  368.    GoToXY(1,1);
  369.    i := 1;
  370.    While (i <= fncnt) AND (i <= 120) Do     { display all filenames }
  371.    Begin
  372.       FNAMEPOS(i,newcurx,newcury);
  373.       GoToXY(newcurx,newcury);
  374.       Write(dos_dir[i]);
  375.       Inc(i)
  376.    End;
  377.    FRAME(1,1,scrrows,80,1);  { draw the frame }
  378.    HILITE(255,1);            { highlight the first filename }
  379.    oldpos := 1;
  380.    newpos := 1;
  381.    While TRUE Do             { get keypress and do appropriate action }
  382.    Begin
  383.       ch := ReadKey;
  384.       Case ch of
  385.          #27:  { Esc  }
  386.          Begin
  387.             Window(1,1,80,25);
  388.             RESTORESCR(screen);
  389.             GoToXY(oldcurx,oldcury);
  390.             CURSOR(ON);
  391.             DIRSELECT := '';
  392.             Exit                       { return NULL }
  393.          End;
  394.          #71:  { Home }                { goto first filename }
  395.          Begin
  396.             oldpos := newpos;
  397.             newpos := 1;
  398.             HILITE(oldpos,newpos)
  399.          End;
  400.          #79:  { End  }                { goto last filename }
  401.          Begin
  402.             oldpos := newpos;
  403.             newpos := fncnt;
  404.             HILITE(oldpos,newpos)
  405.          End;
  406.          #72:  { Up   }                { move up one filename }
  407.          Begin
  408.             i := newpos;
  409.             i := i - 6;
  410.             If i >= 1 Then
  411.             Begin
  412.                oldpos := newpos;
  413.                newpos := i;
  414.                HILITE(oldpos,newpos)
  415.             End
  416.          End;
  417.          #80:  { Down }                { move down one filename }
  418.          Begin
  419.             i := newpos;
  420.             i := i + 6;
  421.             If i <= fncnt Then
  422.             Begin
  423.                oldpos := newpos;
  424.                newpos := i;
  425.                HILITE(oldpos,newpos)
  426.             End
  427.          End;
  428.          #75:  { Left }                { move left one filename }
  429.          Begin
  430.             i := newpos;
  431.             Dec(i);
  432.             If i >= 1 Then
  433.             Begin
  434.                oldpos := newpos;
  435.                newpos := i;
  436.                HILITE(oldpos,newpos)
  437.             End
  438.          End;
  439.          #77:  { Right }               { move right one filename }
  440.          Begin
  441.             i := newpos;
  442.             Inc(i);
  443.             If i <= fncnt Then
  444.             Begin
  445.                oldpos := newpos;
  446.                newpos := i;
  447.                HILITE(oldpos,newpos)
  448.             End
  449.          End;
  450.          #13:  { CR }
  451.          Begin
  452.             Window(1,1,80,25);
  453.             RESTORESCR(screen);
  454.             GoToXY(oldcurx,oldcury);    { return old CURSOR position }
  455.             CURSOR(ON);
  456.             DIRSELECT := dos_dir[newpos];
  457.             Exit                        { return with filename }
  458.          End
  459.       End
  460.    End
  461. End;
  462.  
  463. { ************************************************************************** }
  464. { ** Main Program : NOTE that the following is a demo program only.       ** }
  465. { **                It is not needed to use the DIRSELECT function.       ** }
  466. { ************************************************************************** }
  467.  
  468. Begin
  469.    While TRUE Do
  470.    Begin
  471.       Writeln;
  472.       Write('Enter a filespec => ');
  473.       Readln(spec);
  474.       fname := DIRSELECT(spec,0);
  475.       If Length(fname) = 0 Then
  476.       Begin
  477.          Writeln('Filespec not found.');
  478.          Halt
  479.       End;
  480.       Writeln('The file you have chosen is ',fname,'.')
  481.    End
  482. End.
  483.  
  484. { ** EOF( DIRSEL.PAS )  ** }
  485.